perm filename READX.F4[MUS,LCS] blob
sn#007377 filedate 1974-01-08 generic text, type T, neo UTF8
00100 SUBROUTINE READIN(SOURCE,QUANT,XOUT,FOOGY)
00200 C UNIT GEN. 'READ' = - READ(SOURCE,QUANT,ARY1024,INPUT NCHNS);
00300 C OUTPUTS ARE RDA, RDB, RDC AND RDD. DON'T USE U1, ETC.
00400 C IF SOURCE<100 IT =4TH LETTER. E.G. 4 WILL READ FROM MUSDA (4=D)
00500 C IF SOURCE>100, LAST 2 DIGITS ARE LAST LETTER, 1ST 2 ARE 4TH LETTER.
00600 C E.G. 312 WILL READ FROM MUSCL (3=C, 12=L). 1213 = MUSLM
00700 C LOAD AFTER MUSX,MUSIO,NSCTAP
00800 C MUSIO SHOULD INCLUDE MTA1 CALLS.
00900
01000 COMMON ISAVE
01100 DIMENSION IOUT(1024),XOUT(2046),IH(5),JH(5),KNM(4),NM1(4),NM2(4)
01200 1 ,KCNT(4),XS(4)
01300 C USES ONLY 1023 WDS OF READIN, SENDS BACK 2046 SAMPLES.
01400 DATA IH(1)/' REA'/,IH(2)/'DING '/,IH(4)/' / '/
01500 1 ,(JH(K),K=1,3)/' END OF SECTION'/
01600 EQUIVALENCE (K,IH(5),JH(5)),(JH(4),IH(4))
01700 DO 11 K=1,4
01800 JX=K
01900 11 IF(SOURCE.EQ.XS(K))GO TO 12
02000 NS=NS+1
02100 XS(NS)=SOURCE
02200 JX=NS
02300 C FINDS SOURCE # BEING USED NOW.
02400 12 IF(FOOGY)GO TO 1
02500 C KSIZE IS NUM OF 36-BIT WORDS TO PROCESS.
02600 ISAVE=-1
02700 MTA=0
02800 K=QUANT-1.
02900 JC=0
03000 IF(SOURCE.LT.100.)GO TO 4
03100 NAME=SOURCE/100.
03200 C GETS # FOR 1ST LETTER.
03300 JC=SOURCE-NAME*100
03400 IF(JC.NE.0)JC=JC-1
03500 C GETS 2ND LETTER.
03600 JNM=NAME-1
03700 GO TO 10
03800 4 IF(SOURCE.GT.0)GO TO 2
03900 MTA=-1
04000 JNM=NAME
04100 CC** CALL MTA1
04200 GO TO 3
04300 2 JNM=SOURCE-1.
04400 10 JNM='MUSAA'+256*JNM
04500 3 KNM=JNM
04600 NM1(JX)=JNM+JC*2
04700 NM2(JX)=JNM+2*K
04800 IF(K.GT.26)NM2(JX)=NM1(JX)+256+(K-26)*2
04900 C AMPL. WILL BE NEG. IF LSBUF WAS NOT FULL (LAST BUFFER).
05000 710 IF(MTA)GO TO 811
05100 711 CALL GETFI2(NM1(JX),JX)
05200 IH(3)=NM1(JX)
05300 CALL MESS(IH)
05400 GO TO 810
05500 811 CONTINUE
05600 CC**811 CALL INMTA1(XOUT(1),128)
05700 CC** IF(XOUT(1))GO TO 1201
05800 GO TO 610
05900 810 CALL FASTI2(XOUT(1),128,JX)
06000 KCNT(JX)=2
06100 C JADD IS # OF 128 WD. RECORDS READ.
06200 610 IF(MTA)GO TO 611
06300 CALL FASTI2(XOUT(1),1024,JX)
06400 KCNT(JX)=KCNT(JX)+8
06500 GO TO 612
06600 C LAST WORD IS THROWN AWAY.
06700 611 CONTINUE
06800 CC**614 CALL MTA1
06900 CC**611 CALL INMTA1(XOUT(1),1024)
07000 612 JC=XOUT(1024)
07100 IF(JC)5,9,6
07200 5 CALL MESS(JH)
07300 6 NM1(JX)=NM1(JX)+2
07400 IF(NM1(JX).LE.JNM+50)GO TO 27
07500 JNM=JNM+256
07600 C RAISES 'AAAZA' TO 'AABAA'
07700 1017 NM1(JX)=JNM
07800 27 IF(NM1(JX).LE.NM2(JX))GO TO 710
07900 1201 NM2(JX)=NM1(JX)-1
08000 9 RETURN
08100 1 IF(ISAVE)GO TO 171
08200 ISAVE=-1
08300 IF(NM1(JX).GT.NM2(JX))GO TO 171
08400 CC** IF(MTA)GO TO 614
08500 C CANNOT START UP MTA1 AGAIN IF TAPE IS MOVED.
08600 CALL GETFI2(NM1(JX),JX)
08700 CALL USETI(KCNT(JX))
08800 C*** NOT YET FIXED FOR READING MAGTAPE!!!
08900 171 IF(NM1(JX).LE.NM2(JX))GO TO 610
09000 IF(JC.EQ.-1)RETURN
09100 DO 7 K=1,2046
09200 7 XOUT(K)=0
09300 JC=-1
09400 RETURN
09500 C ZEROS ARRAY IF NO MORE IS READ IN.
09600 END